home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / bev2slib.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  119 lines
  1. ;; Copyright (C) 1997 Free Software Foundation, Inc.
  2. ;;
  3. ;; This program is free software; you can redistribute it and/or modify
  4. ;; it under the terms of the GNU General Public License as published by
  5. ;; the Free Software Foundation; either version 2, or (at your option)
  6. ;; any later version.
  7. ;;
  8. ;; This program is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;; GNU General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU General Public License
  14. ;; along with this software; see the file COPYING.  If not, write to
  15. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ;;
  17. ;; As a special exception, the Free Software Foundation gives permission
  18. ;; for additional uses of the text contained in its release of GUILE.
  19. ;;
  20. ;; The exception is that, if you link the GUILE library with other files
  21. ;; to produce an executable, this does not by itself cause the
  22. ;; resulting executable to be covered by the GNU General Public License.
  23. ;; Your use of that executable is in no way restricted on account of
  24. ;; linking the GUILE library code into it.
  25. ;;
  26. ;; This exception does not however invalidate any other reasons why
  27. ;; the executable file might be covered by the GNU General Public License.
  28. ;;
  29. ;; This exception applies only to the code released by the
  30. ;; Free Software Foundation under the name GUILE.  If you copy
  31. ;; code from other Free Software Foundation releases into a copy of
  32. ;; GUILE, as the General Public License permits, the exception does
  33. ;; not apply to the code that you add in this way.  To avoid misleading
  34. ;; anyone as to the status of such modified files, you must delete
  35. ;; this exception notice from them.
  36. ;;
  37. ;; If you write modifications of your own for GUILE, it is your choice
  38. ;; whether to permit this exception to apply to your modifications.
  39. ;; If you do not wish that, delete this exception notice.
  40.  
  41. ;;;; "Bev2slib.scm" Build SLIB catalogs for Stephen Bevan's libraries.
  42. ;;; Author: Aubrey Jaffer.
  43.  
  44. ;;; Put this file into the implementation-vicinity directory for your
  45. ;;; scheme implementation.
  46.  
  47. ;;; Add the line
  48. ;;;    (load (in-vicinity (implementation-vicinity) "Bev2slib.scm"))
  49. ;;; to "mkimpcat.scm"
  50.  
  51. ;;; Delete "slibcat" in your implementation-vicinity.
  52.  
  53. ;;; Bind `Bevan-dir' to the directory containing directories "bawk",
  54. ;;; "mawk", "pathname", etc.  Bev2slib.scm will put entries into the
  55. ;;; catalog only for those directories and files which exist.
  56.  
  57. (let ((Bevan-dir (in-vicinity (library-vicinity) "../"));"/usr/local/lib/Bevan/"
  58.       (catname "sitecat"))
  59.   (call-with-output-file (in-vicinity (implementation-vicinity) catname)
  60.     (lambda (op)
  61.       (define (display* . args)
  62.     (for-each (lambda (arg) (display arg op)) args)
  63.     (newline op))
  64.       (define (add-alias from to)
  65.     (display " " op)
  66.     (write (cons from to) op)
  67.     (newline op))
  68.  
  69.       (begin
  70.     (display* ";\"" catname "\" Site-specific SLIB catalog for "
  71.           (scheme-implementation-type) (scheme-implementation-version)
  72.           ".  -*-scheme-*-")
  73.     (display* ";")
  74.     (display* ";            DO NOT EDIT THIS FILE")
  75.     (display* "; it is automagically generated by \"Bev2slib.scm\"")
  76.     (newline op)
  77.     )
  78.  
  79.       ;; Output association lists to file "sitecat"
  80.  
  81.       (for-each
  82.        (lambda (dir)
  83.      (let* ((vic (in-vicinity Bevan-dir (string-append dir "/")))
  84.         (map-file (in-vicinity vic (string-append dir ".map"))))
  85.  
  86.        (display* ";;; from " map-file)
  87.        (display* "(")
  88.  
  89.        (and
  90.         (file-exists? map-file)
  91.         (call-with-input-file map-file
  92.           (lambda (ip)
  93.         (define files '())
  94.         (do ((feature (read ip) (read ip)))
  95.             ((eof-object? feature))
  96.           (let* ((type (read ip))
  97.              (file (read ip))
  98.              (fsym (string->symbol (string-append "Req::" file))))
  99.             (and (not (assq fsym files))
  100.              (set! files (cons (cons fsym file) files)))
  101.             (add-alias feature fsym)))
  102.         (for-each
  103.          (lambda (pr) (add-alias (car pr) (in-vicinity vic (cdr pr))))
  104.          files)
  105.         )))
  106.  
  107.        (display* ")")))
  108.  
  109.        '("char-set" "conc-string" "string" "string-03"
  110.             "avl-tree" "avl-trie"
  111.             "bawk" "mawk" "pathname"))
  112.  
  113.       (begin
  114.     (display* "(")
  115.     (add-alias 'btree (in-vicinity Bevan-dir "bawk/btree"))
  116.     (add-alias 'read-line 'line-i/o)
  117.     (display* ")")
  118.     ))))
  119.